home *** CD-ROM | disk | FTP | other *** search
/ Amiga Collections: Memphis Amiga Group / MAG Disk (1989-11)(Memphis Amiga Group).zip / MAG Disk (1989-11)(Memphis Amiga Group).adf / HeadClean / hc_drive_gads < prev    next >
Text File  |  1986-11-06  |  3KB  |  135 lines
  1. \ Drive Gadgets for HeadClean
  2. \
  3. \ Author: Phil Burk
  4. \ Copyright 1987,8,9 Phil Burk
  5. \
  6. \ This program is a freely redistributable shareware program.
  7.  
  8. ANEW TASK-HC_DRIVE_GADS
  9.  
  10. \ Use an arrow to point to the chosen disk drive.--------------
  11. \ This is an Intuition Image structure.
  12. Image ARROW-IMAGE
  13.  
  14. \ Define bitmap for arrow
  15. create ARROW-BITS
  16. BINARY   \ Enter bits in binary, base 2
  17. \ 0123456789ABCDEF
  18. here
  19.   0011111111100000 w,
  20.   0001111111000000 w,
  21.   0000111110000000 w,
  22.   0000111110000000 w,
  23.   0000111110000000 w,
  24.   0000111110000000 w,
  25.   1000111110001000 w,
  26.   1111111111111000 w,
  27.   0111111111110000 w,
  28.   0011111111100000 w,
  29.   0001111111000000 w,
  30.   0000111110000000 w,
  31.   0000011100000000 w,
  32.   0000001000000000 w,
  33. here swap - 2/ constant ARROW_HEIGHT  ( calculate how many rows )
  34. DECIMAL
  35.  
  36. variable ARROW-BITS-PTR
  37.  
  38. : ARROW.INIT  ( -- , setup IntuiImage )
  39. \ Try to copy image to CHIP RAM for use by Graphics Chips
  40.     memf_chip arrow_height 2* allocblock ?dup
  41.     IF  dup arrow-bits-ptr !
  42.         arrow-bits-ptr @ >abs  arrow-image ..! ig_imagedata
  43.         arrow-bits swap arrow_height 2* cmove
  44.     ELSE \ Just use garbage data cuz couldn't alloc RAM for copy
  45.         8 arrow-image ..! ig_imagedata
  46.     THEN
  47. \
  48.     13 arrow-image ..! ig_width
  49.     arrow_height arrow-image ..! ig_height
  50.     1  arrow-image ..! ig_depth
  51. \
  52. \ Draw using color 1
  53.     1 arrow-image ..! ig_PlanePick
  54.     NULL arrow-image ..! ig_NextImage
  55. ;
  56.  
  57. : ARROW.TERM  ( -- , deallocate image in CHIP RAM )
  58.     arrow-bits-ptr @ ?dup
  59.     IF freeblock arrow-bits-ptr off
  60.     THEN
  61. ;
  62.  
  63. : DRAW.ARROW ( x y -- , draw arrow to show which drive is active )
  64.     >r >r
  65.     gr-currport @  ( rastport already absolute for speed )
  66.     arrow-image >abs  ( use absolute address )
  67.     r> r>
  68.     callvoid Intuition_lib DrawImage
  69. ;
  70.  
  71. : HC.POINT.DRIVE ( drive# color -- , make arrow point to drive )
  72.     arrow-image ..! ig_PlanePick
  73.     hc_gadget_inc * hc_gadget_x +
  74.     10 +  hc_show_y draw.arrow
  75. ;
  76.  
  77. : XY+  ( x y xinc yinc -- x' y' )
  78.     rot + >r
  79.     + r>
  80. ;
  81.  
  82. : HC.MARK.DRIVE  ( drive# -- , mark with a check to show cleaned )
  83.     hc_gadget_inc * hc_gadget_x + 10 +
  84.     hc_gadget_y hc_gadget_h + 9 + ( starting x,y )
  85.     2dup gr.move 3 gr.color!
  86.     3 5 xy+ 2dup gr.draw
  87.     6 -10 xy+ gr.draw
  88.     1 gr.color!
  89. ;
  90.  
  91. : HC.GADGETS.OFF ( -- , turn off arrow above other drives )
  92.     4 0
  93.     DO i 0 hc.point.drive
  94.     LOOP
  95. ;
  96.  
  97. : HC.SHOW.DRIVE  ( -- , show which drive is current )
  98.     hc.gadgets.off
  99.     clean-drive @ 1 hc.point.drive
  100. ;
  101.  
  102. : HC.DRIVE  ( drive -- )
  103.     clean-drive !
  104.     gr-curwindow @
  105.     IF hc.show.drive
  106.     THEN
  107. ;
  108.  
  109. \ ----------------------------------------------    
  110. : HC.DRIVE.0  ( -- , select this drive )
  111.     0 hc.drive
  112. ;
  113. : HC.DRIVE.1  ( -- , select this drive )
  114.     1 hc.drive
  115. ;
  116. : HC.DRIVE.2  ( -- , select this drive )
  117.     2 hc.drive
  118. ;
  119. : HC.DRIVE.3  ( -- , select this drive )
  120.     3 hc.drive
  121. ;
  122.  
  123. \ Initialize drive gadgets.
  124. : DRIVE.BUTTONS.INIT  ( init buttons for drive 0,1,2,3 )
  125. \ Put values on stack to be eaten in DO LOOP
  126.     ' hc.drive.3 0" DF3:"
  127.     ' hc.drive.2 0" DF2:"
  128.     ' hc.drive.1 0" DF1:"
  129.     ' hc.drive.0 0" DF0:"
  130.     4 0
  131.     DO  hc_gadget_x hc_gadget_inc i * +  ( xpos )
  132.         hc_gadget_y hc_w_h   gt.gad.make
  133.     LOOP
  134. ;
  135.